perm filename FUSUB.F4[FUN,LCS] blob sn#375363 filedate 1978-08-24 generic text, type T, neo UTF8
	SUBROUTINE LO2UP(J)
C CONVERTS ALL LOWER CASE TO UPPER CASE.
	J=J.AND..NOT.((J/2).AND."201004020100)
	END
	
	SUBROUTINE ACLOUP(I,J)
	ACCEPT 1,I,J
	CALL LO2UP(I)
	CALL LO2UP(J)
1 	FORMAT(A1,A3)
	END

	SUBROUTINE FILNAM(F)
	DIMENSION FN(10),FRMT(3),FFF(5)
	COMMON FUNC(512),F2(512),K,I 
	EQUIVALENCE (FUNC,FN),(A,FN(10))
	DATA FRMT/'(A',0,')'/,FFF/'1','2','3','4','5'/
1	FORMAT(20A1)
	ACCEPT 1,FN
	IF(FN(1).EQ.' ')RETURN
	DO 2 K=2,9
	A=FN(K)
	IF(A.EQ.' ')GO TO 3
2	IF(A.EQ.'.')GO TO 3
	CALL EXIT
C EXIT IF GARBAGE
3	FRMT(2)=FFF(K-1)
	REREAD FRMT,F
	CALL LO2UP(F)
	END

	SUBROUTINE ZFUNC
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	COMMON FUNC(512),F2(512),K,I

43	TYPE 1
	ACCEPT 100,MA,C
	CALL LO2UP(MA)
	IF(MA.NE.'B')GO TO 76
430	KT=512
C  FOR BACKUP
	RETURN
76	IF(MA.EQ.'A')GO TO 75
	IF(MA.NE.'M')GO TO 73
75	TYPE 39,B
	TYPE 2
	ACCEPT 3,FNM2
	CALL LO2UP(FNM2)
	IF(FNM2.EQ.'B')GO TO 43
40	DO 4 K=1,10
5	IF(FNM2.NE.FN(K))GO TO 4
	N2=K
	GO TO 72
4	CONTINUE
	TYPE 74
	GO TO 75
74	FORMAT(' FUNCTION NOT FOUND '/)
72	CALL DPYF(N2,F2)
7	TYPE 60
	ACCEPT 100,K
	CALL LO2UP(K)
	IF(K.EQ.'B')GO TO 15
	IF(K.EQ.'N')GO TO 15
	IF(MA.EQ.'M')GO TO 102
70	TYPE 10
	ACCEPT 11,R,R2
	REREAD 100,K
	CALL LO2UP(K)
	IF(K.EQ.'B')GO TO 75
	IF(R2.EQ.0)R2=1
	IF(R.EQ.0)R=1
	DO 13 K=1,512
	X=FUNC(K)
	FUNC(K)=FUNC(K)*R+F2(K)*R2+C
13	F2(K)=X
	GO TO 104
73	IF(MA.NE.'C')GO TO 44
	DO 45 K=1,512
	F2(K)=FUNC(K)
45	FUNC(K)=FUNC(K)+C
	GO TO 104
44	IF(MA.NE.'I')GO TO 46
	DO 47 K=1,512
	F2(K)=FUNC(K)
47	FUNC(K)=C-FUNC(K)
	GO TO 104
46	IF(MA.NE.'R')GO TO 75
48	DO 50 K=1,512
50	F2(K)=FUNC(513-K)
	DO 51 K=1,512
	X=FUNC(K)
	FUNC(K)=F2(K)+C
51	F2(K)=X
	GO TO 104
102	DO 103 K=1,512
	X=FUNC(K)
	FUNC(K)=FUNC(K)*F2(K)+C
103	F2(K)=X
104	A(1,2)=520
	CALL NORM(FUNC)
C   NORMALIZES THE FUNCTION
	CALL DPY(FUNC,1)
	TYPE 6
	ACCEPT 100,K
	CALL LO2UP(K)
	IF(K.EQ.'M')GO TO 43
	IF(K.NE.'B')RETURN
	DO 14 K=1,512
14	FUNC(K)=F2(K)
15	CALL DPY(FUNC,1)
	GO TO 43
1	FORMAT
     1(' A(DD), M(ULT), R(ETRO), I(NVRT), OR C,N (=ADD CONSTANT N) ',$)
100	FORMAT(A1,F)
2	FORMAT(' 2ND FUNC? ',$)
3	FORMAT(A3)
10	FORMAT(' TYPE RATIO (E.G. 1,2) ',$)
39	FORMAT(10(A1,A3))
11	FORMAT(2F)
6	FORMAT(' F(INISH), OR M(ORE)?  ',$)
60	FORMAT(' GO ON?  ',$)
	END

	SUBROUTINE DPYF(N,F)
	COMMON/S/H,AMP,CON,PH /GRD/ON
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	DIMENSION F(1)
	NODPY=-1
	IF(N.GT.0)GO TO 8
	N=JX
	NODPY=0
CC COLGATE 6/74--SEE MAIN AT 1201-18	IF(XA(N).EQ.'SEG')GO TO 5
8	IF(XA(N).NE.'SYNTH')GO TO 5
	CALL ZERO(F)
	K=1
1	AMP=AA(2,K,N)
	H=AA(1,K,N)
	PH=AA(3,K,N)
	CON=AA(4,K,N)
	CALL SYN(F)
	K=K+1
	IF(AA(1,K,N).NE.999)GO TO 1
	CALL NORM(F)
	GO TO 4

5	K=1
	G=AA(2,1,N)
	IF(G.EQ.520)GO TO 6
	J=1
	IF(G.LE.1)GO TO 22
	Y=0
	K=0
C  FOR START BEYOND STEP 1 - ASSUMES A 0,1.
	GO TO 2
22	Y=AA(1,1,N)
2	K=K+1
	M=AA(2,K,N)*5.12+.5
	IF(M.GT.512)GO TO 6
	G=AA(1,K,N)
	Z=G-Y
	H=M-J+1
	IF(H.LT.1)H=1
	NN=0
	DO 3 L=J,M
	F(L)=(NN*Z)/H+Y
3	NN=NN+1
	IF(M.EQ.512)GO TO 4
	Y=G
	J=M+1
	GO TO 2
C  FOR LONG FUNCS.
6	L=K+1
	DO 7 M=1,512
7	F(M)=AA(M,L,N)
4	IF(NODPY)CALL DPY(F,-1)
C  NODPY=0 IS FOR PLOTTER AND LPT
C  NOW FUNCTION IS FULL AND DISPLAYED
	END

	SUBROUTINE SYN(F)
	COMMON/S/H,AMP,CON,PH
	DIMENSION F(1)
	DATA FAC/0.703125/,FACP/1.422222/
	X=PH*FACP+1.0
C  PHASE IS IN DEGREES (0 - 360)
2016	DO 17 L=1,512
	XL=SIND(X*FAC)*AMP+CON
	IF(CON.LT.100.0)GO TO 1
	F(L)=(XL-100.)*F(L)
	GO TO 2
1	F(L)=F(L)+XL
C   NORMALIZES THE FUNCTION
2	X=X+H
17	IF(X.GT.512.)X=X-512.
	END

	SUBROUTINE ZERO(F)
	DIMENSION F(1)
	DO 1 K=1,512
1	F(K)=0
	RETURN
	END

	SUBROUTINE NORM(F)
	DIMENSION F(1)
	X=F(1)
C   NORMALIZES THE FUNCTION
	DO 19 K=2,512
	XK=ABS(F(K))
19	IF(X.LT.XK)X=XK
	DO 20 K=1,512
20	F(K)=F(K)/X
	RETURN
	END